perm filename SHIT[900,BGB] blob
sn#129608 filedate 1974-11-12 generic text, type T, neo UTF8
(SETQ IBASE (ADD1 7))
(DEFPROP ALLFNS
(NIL PUTO
CORREL2
CORREL
ZPRIN
LPTH2
LPTH
PEAK
MAXN
SIEVE2
CH
PH
CROSSINGS
DIFFS
BLOB
MINAXX
MINAXY
HISTO2
HISTO
TVPRIN
SUMSQ
SUMM
LENG
LENGTH
SIEVE
DEL
PHISTO
CHIST
CTVF3
FILTER
CD
L
Q
C
PUTON
NAME
COLOR
SCALE
DUMP3
DUMP2
CTVF2
FRAME
SAFE
DUMP
TABLE
WALL
CLIPX
QW
TV
PRINTV
WINALL)
VALUE)
(DEFPROP PUTO
(LAMBDA(A Z)
(PROG (B Z1 Z2)
(SETQ Z1 NIL)
(SETQ Z2 Z)
(SETQ B A)
L (COND ((NULL Z2) (RETURN (APPEND Z1) (NCONS A))))
(COND
((AND (LESSP (CDR A) (CDAR Z))
(GREATERP (CDR A) (CDR B))
(LESSP (CAR A) (CAAR Z))
(GREATERP (CAR A) (CAR B)))
(RETURN (APPEND Z1 (CONS A Z2))))
(SETQ B (CAR Z2))
(SETQ Z1 (APPEND Z1 (NCONS (CAR Z2))))
(SETQ Z2 (CDR Z2))
(GO L))))
EXPR)
(DEFPROP CORREL2
(LAMBDA(MM)
(PROG NIL
(CH)
(HISTO2 Z MM)
(SETQ P (PH))
(SETQ W (PEAK (CONS 0 (CROSSINGS (DIFFS P) 1)) (MAXN P 0 -1 0)))
(SETQ C (CONS (CONS (SUB1 (TIMES 3 (CAR W))) (TIMES 3 (CDR W))) C))))
EXPR)
(DEFPROP CORREL
(LAMBDA(MIN MAX X Y)
(PROG (Z P W C)
(SETQ C (LIST (CONS (SUB1 (TIMES 3 MIN)) (TIMES 3 MAX))))
(SETQ Z (SIEVE X Y 1 (CAAR C) (CDAR C)))
(CORREL2 2)
(SETQ Z (SIEVE2 Z 2 (CAAR C) (CDAR C)))
(CORREL2 3)
(SETQ Z (SIEVE2 Z 3 (CAAR C) (CDAR C)))
(CORREL2 0)
(SETQ Z (SIEVE2 Z 0 (CAAR C) (CDAR C)))
(RETURN (CONS C Z))))
EXPR)
(DEFPROP ZPRIN
(LAMBDA(X Y Z)
(PROG (XX YY NN I J)
(SETQ NN 0)
L3 (SETQ YY Y)
(TERPRI)
L2 (SETQ XX X)
(TERPRI)
L1 (COND ((MEMBER (CONS XX YY) Z) (PRINC (QUOTE X))) (T (PRINC (QUOTE / ))))
(COND ((GREATERP (PLUS X 77) (SETQ XX (ADD1 XX))) (GO L1)))
(COND ((GREATERP (PLUS Y 77) (SETQ YY (ADD1 YY))) (GO L2)))))
EXPR)
(DEFPROP LPTH2
(LAMBDA (N) (COND ((ZEROP N) (TERPRI)) (T (PROG2 (PRINC (QUOTE XX)) (LPTH2 (SUB1 N))))))
EXPR)
(DEFPROP LPTH
(LAMBDA (Z) (COND ((NULL Z) NIL) (T (PROG2 (LPTH2 (CAR Z)) (LPTH2 (CAR Z)) (LPTH2 (CAR Z)) (LPTH (CDR Z))))))
EXPR)
(DEFPROP PEAK
(LAMBDA(Z M)
(COND ((NULL (CDR Z)) (CONS (CAR Z) 17))
(T
(COND ((OR (LESSP (CAR Z) M (CADR Z)) (EQ (CAR Z) M) (EQ (CADR Z) M)) (CONS (CAR Z) (CADR Z)))
(T (PEAK (CDR Z) M))))))
EXPR)
(DEFPROP MAXN
(LAMBDA(Z N MAX MXN)
(COND ((NULL Z) MXN)
(T
(COND ((GREATERP (CAR Z) MAX) (MAXN (CDR Z) (ADD1 N) (CAR Z) N))
(T (MAXN (CDR Z) (ADD1 N) MAX MXN))))))
EXPR)
(DEFPROP SIEVE2
(LAMBDA(Z N MIN MAX)
(PROG (ZZ A)
(SETQ ZZ Z)
(SETQ A NIL)
L (COND ((NULL ZZ) (RETURN A)))
(COND ((GREATERP MAX (FETCH N (CAAR ZZ) (CDAR ZZ)) MIN) (SETQ A (CONS (CAR ZZ) A))))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP CH
(LAMBDA NIL (CHIST 17))
EXPR)
(DEFPROP PH
(LAMBDA NIL (PHISTO 17))
EXPR)
(DEFPROP CROSSINGS
(LAMBDA(Z N)
(COND ((NULL (CDR Z)) NIL)
(T
(COND ((AND (MINUSP (CADR Z)) (NOT (MINUSP (CAR Z)))) (CONS N (CROSSINGS (CDR Z) (ADD1 N))))
(T (CROSSINGS (CDR Z) (ADD1 N)))))))
EXPR)
(DEFPROP DIFFS
(LAMBDA (Z) (COND ((NULL (CDR Z)) NIL) (T (CONS (DIFFERENCE (CAR Z) (CADR Z)) (DIFFS (CDR Z))))))
EXPR)
(DEFPROP BLOB
(LAMBDA(Z)
(PROG (N AX AY AA)
(SETQ N (LENG Z))
(SETQ AA (SUMM Z))
(SETQ AX (QUOTIENT (CAR AA) N))
(SETQ AY (QUOTIENT (CDR AA) N))
(SETQ AA (SUMSQ Z))
(SETQ AA (QUOTIENT (PLUS (CAR AA) (CDR AA)) N))
(SETQ AA (DIFFERENCE AA (TIMES AX AX) (TIMES AY AY)))
(RETURN (LIST (CONS AX AY) (MINAXX Z) (MINAXY Z) (CONS AA N)))))
EXPR)
(DEFPROP MINAXX
(LAMBDA(Z)
(PROG (X Y ZZ)
(SETQ ZZ Z)
(SETQ X 10000)
(SETQ Y 0)
L (COND ((NULL ZZ) (RETURN (CONS X Y))))
(COND ((GREATERP (CAAR ZZ) Y) (SETQ Y (CAAR ZZ))))
(COND ((GREATERP X (CAAR ZZ)) (SETQ X (CAAR ZZ))))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP MINAXY
(LAMBDA(Z)
(PROG (X Y ZZ)
(SETQ ZZ Z)
(SETQ X 10000)
(SETQ Y 0)
L (COND ((NULL ZZ) (RETURN (CONS X Y))))
(COND ((GREATERP (CDAR ZZ) Y) (SETQ Y (CDAR ZZ))))
(COND ((GREATERP X (CDAR ZZ)) (SETQ X (CDAR ZZ))))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP HISTO2
(LAMBDA(Z N)
(PROG (ZZ J)
(SETQ ZZ Z)
L (COND ((NULL ZZ) (RETURN NIL)))
(SETQ J (QUOTIENT (FETCH N (CAAR ZZ) (CDAR ZZ)) 3))
(STORE (HIST J) (ADD1 (HIST J)))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP HISTO
(LAMBDA(X Y N)
(PROG (XX YY NN I J)
(SETQ NN N)
L3 (SETQ YY Y)
L2 (SETQ XX X)
L1 (SETQ J (FETCH NN XX YY))
(STORE (HIST (QUOTIENT J 3)) (ADD1 (HIST (QUOTIENT J 3))))
(COND ((GREATERP (PLUS X 77) (SETQ XX (ADD1 XX))) (GO L1)))
(COND ((GREATERP (PLUS Y 77) (SETQ YY (ADD1 YY))) (GO L2)))))
EXPR)
(DEFPROP TVPRIN
(LAMBDA(X Y)
(PROG (XX YY NN I J)
(SETQ NN 0)
L3 (SETQ YY Y)
(TERPRI)
L2 (SETQ XX X)
(TERPRI)
L1 (SETQ J (FETCH NN XX YY))
(PRINC (QUOTIENT J 6))
(COND ((GREATERP (PLUS X 77) (SETQ XX (ADD1 XX))) (GO L1)))
(COND ((GREATERP (PLUS Y 77) (SETQ YY (ADD1 YY))) (GO L2)))
(COND ((GREATERP 4 (SETQ NN (ADD1 NN))) (GO L3)))))
EXPR)
(DEFPROP SUMSQ
(LAMBDA(Z)
(PROG (X Y ZZ)
(SETQ ZZ Z)
(SETQ X 0)
(SETQ Y 0)
L (COND ((NULL ZZ) (RETURN (CONS X Y))))
(SETQ X (PLUS X (TIMES (CAAR ZZ) (CAAR ZZ))))
(SETQ Y (PLUS Y (TIMES (CDAR ZZ) (CDAR ZZ))))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP SUMM
(LAMBDA(Z)
(PROG (X Y ZZ)
(SETQ ZZ Z)
(SETQ X 0)
(SETQ Y 0)
L (COND ((NULL ZZ) (RETURN (CONS X Y))))
(SETQ X (PLUS X (CAAR ZZ)))
(SETQ Y (PLUS Y (CDAR ZZ)))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP LENG
(LAMBDA(Z)
(PROG (N ZZ)
(SETQ ZZ Z)
(SETQ N 0)
L (COND ((NULL ZZ) (RETURN N)))
(SETQ N (ADD1 N))
(SETQ ZZ (CDR ZZ))
(GO L)))
EXPR)
(DEFPROP LENGTH
(LAMBDA (Z) (COND ((NULL Z) 0) (T (ADD1 (LENGTH (CDR Z))))))
EXPR)
(DEFPROP SIEVE
(LAMBDA(X Y N MIN MAX)
(PROG (XX YY NN I J ZZ)
(SETQ ZZ NIL)
(SETQ NN N)
L3 (SETQ YY Y)
L2 (SETQ XX X)
L1 (SETQ J (FETCH NN XX YY))
(COND ((AND (GREATERP MAX J) (GREATERP J MIN)) (SETQ ZZ (CONS (CONS XX YY) ZZ))))
(COND ((GREATERP (PLUS X 77) (SETQ XX (ADD1 XX))) (GO L1)))
(COND ((GREATERP (PLUS Y 77) (SETQ YY (ADD1 YY))) (GO L2)))
(RETURN ZZ)))
EXPR)
(DEFPROP DEL
(LAMBDA (A B) (COND ((NULL A) NIL) (T (CONS (DIFFERENCE (CAR A) (CAR B)) (DEL (CDR A) (CDR B))))))
EXPR)
(DEFPROP PHISTO
(LAMBDA (N) (COND ((MINUSP N) NIL) (T (CONS (HIST (DIFFERENCE 17 N)) (PHISTO (SUB1 N))))))
EXPR)
(DEFPROP CHIST
(LAMBDA (N) (PROG2 (STORE (HIST N) 0) (COND ((NOT (ZEROP N)) (CHIST (SUB1 N))))))
EXPR)
(DEFPROP CTVF3
(LAMBDA NIL
(PROG (M)
(SETQ M 0)
(ZIP)
L1 (COND ((GREATERP (SWS) 1) (GO L1)))
L3 (COND
((EQ 2 (SWS))
(PROG NIL
(INTV)
(TVADD M)
(INTV)
(TVADD M)
(INTV)
(TVADD M)
(SETQ M (ADD1 M))
L2 (COND ((EQ 2 (SWS)) (GO L2)))
(RETURN NIL))))
(COND ((EQ M 4) (RETURN T)))
(GO L3)))
EXPR)
(DEFPROP FILTER
(LAMBDA NIL
(PROG (Q M)
(SETQ M 0)
L (SETQ Q (SWS))
(COND ((GREATERP Q 3) (RETURN NIL))
((EQ Q 3) (GO L))
(T
(PROG (QQ)
(COND ((EQ 4 (PRINT (SETQ M (ADD1 M)))) (PROG2 (SETQ M 0) (TERPRI))))
LL (COND ((EQ (SWS) 3) (RETURN NIL)))
(GO LL))))
(GO L)))
EXPR)
(DEFPROP CD
(LAMBDA(X Y)
(PROG NIL (WINALL (PLUS X -4) (PLUS Y -4) 2 22) (SETQ Z2 (COLOR X Y 6 6)) (RETURN (NAME (CAR) (CADR) L))))
EXPR)
(DEFPROP L
(NIL (ZPRIN 220 300 Z))
VALUE)
(DEFPROP Q
(LAMBDA (QQ) (PROG (Z2) (SETQ Z2 (COLOR 204 204 20 20)) (SETQ L (CONS (CDDR Z2) (CONS QQ L))) (RETURN Z2)))
EXPR)
(DEFPROP Q
(NIL PLUS (273 316 572 635 633 253 55 437 1160 316 1011 602 65 25 45 27))
VALUE)
(DEFPROP C
(LAMBDA NIL (PROG (Z2) (SETQ Z2 (COLOR 204 204 20 20)) (RETURN (NAME (CAR Z2) (CADR Z2) L))))
EXPR)
(DEFPROP C
(NIL (-1 . 25) -1 . 11)
VALUE)
(DEFPROP PUTON
(LAMBDA (Z L NAM) (SET L (CONS (CDDR Z) (CONS NAM L))))
EXPR)
(DEFPROP NAME
(LAMBDA(X Y L)
(COND ((NULL L) NIL)
((AND (GREATERP X (CAAR L))
(GREATERP (CADAR L) X)
(GREATERP Y (CADDAR L))
(GREATERP (CAR (CDDDAR L)) Y))
(CONS (CADR L) (NAME X Y (CDDR L))))
(T (NAME X Y (CDDR L)))))
EXPR)
(DEFPROP COLOR
(LAMBDA (X Y W H) (PROG NIL (ZIP) (CTVF1) (RETURN (DUMP3 X Y W H))))
EXPR)
(DEFPROP SCALE
(LAMBDA (Q) (FIX (PLUS -600 (TIMES 1400 Q))))
EXPR)
(DEFPROP DUMP3
(LAMBDA(X Y W H)
(PROG (XXXX YYYY XMAX XMIN YMAX YMIN XX YY XXX YYY NNN B R G I)
(SETQ XXXX (SETQ YYYY 0))
(SETQ XMAX (SETQ YMAX -1000))
(SETQ XMIN (SETQ YMIN 1000))
(SETQ YY Y)
LL (SETQ XX X)
(TERPRI)
L (SETQ B (FETCH 0 XX YY))
(SETQ R (FETCH 1 XX YY))
(SETQ G (FETCH 2 XX YY))
(SETQ I (FETCH 3 XX YY))
(SETQ XXXX (PLUS XXXX (SETQ XXX (QUOTIENT R (SETQ NNN (PLUS R B G 0.0))))))
(SETQ YYYY (PLUS YYYY (SETQ YYY (QUOTIENT G NNN))))
(COND ((GREATERP XXX XMAX) (SETQ XMAX XXX)))
(COND ((GREATERP XMIN XXX) (SETQ XMIN XXX)))
(COND ((GREATERP YYY YMAX) (SETQ YMAX YYY)))
(COND ((GREATERP YMIN YYY) (SETQ YMIN YYY)))
(COND ((GREATERP (PLUS X W) (SETQ XX (ADD1 XX))) (GO L)))
(COND ((GREATERP (PLUS Y H) (SETQ YY (ADD1 YY))) (GO LL)))
(SETQ XXX (QUOTIENT XXXX (TIMES W H)))
(SETQ YYY (QUOTIENT YYYY (TIMES W H)))
(AIVECT (SCALE XXX) (SCALE YMAX))
(RVECT 0 (FIX (TIMES 1400 (DIFFERENCE YMIN YMAX))))
(AIVECT (SCALE XMAX) (SCALE YYY))
(RVECT (FIX (TIMES 1400 (DIFFERENCE XMIN XMAX))) 0)
(SHOW 2)
(RETURN (LIST XXX YYY XMIN XMAX YMIN YMAX))))
EXPR)
(DEFPROP DUMP2
(LAMBDA(X Y W H)
(PROG (XX YY XXX YYY NNN B R G I)
(SETQ YY Y)
LL (SETQ XX X)
(TERPRI)
L (SETQ B (FETCH 0 XX YY))
(SETQ R (FETCH 1 XX YY))
(SETQ G (FETCH 2 XX YY))
(SETQ I (FETCH 3 XX YY))
(SETQ XXX (QUOTIENT R (SETQ NNN (PLUS R B G 0.0))))
(SETQ YYY (QUOTIENT G NNN))
(APT (FIX (PLUS -600 (TIMES 1400 XXX))) (FIX (PLUS -600 (TIMES 1400 YYY))))
(COND ((GREATERP (PLUS X W) (SETQ XX (ADD1 XX))) (GO L)))
(COND ((GREATERP (PLUS Y H) (SETQ YY (ADD1 YY))) (GO LL)))
(SHOW 1)))
EXPR)
(DEFPROP CTVF2
(LAMBDA(N)
(PROG NIL
(INTV)
(TVADD N)
(INTV)
(TVADD N)
(INTV)
(TVADD N)
(INTV)
(TVADD N)
(INTV)
(TVADD N)
(INTV)
(TVADD N)
(INTV)
(TVADD N)
(INTV)
(TVADD N)))
EXPR)
(DEFPROP FRAME
(LAMBDA NIL
(PROG NIL
(CLEAR)
(KILL 0)
(AIVECT -600 -600)
(RVECT 1400 0)
(RVECT 0 1400)
(RVECT -1400 0)
(RVECT 0 -1400)
(SHOW 0)))
EXPR)
(DEFPROP SAFE
(LAMBDA NIL (DSKOUT SHIT (GRINL ALLFNS)))
EXPR)
(DEFPROP DUMP
(LAMBDA(X Y W H)
(PROG (XX YY XXX YYY NNN B R G I)
(SETQ YY Y)
LL (SETQ XX X)
(TERPRI)
L (SETQ B (FETCH 0 XX YY))
(SETQ R (FETCH 1 XX YY))
(SETQ G (FETCH 2 XX YY))
(SETQ I (FETCH 3 XX YY))
(SETQ XXX (PLUS (TIMES B 0.99999990E-1) (TIMES R 0.70000000) (TIMES G 0.19999998)))
(SETQ YYY (PLUS (TIMES B 0.99999990E-1) (TIMES R 0.30000000) (TIMES G 0.79999998)))
(APT (FIX (PLUS -600 (TIMES 3 XXX))) (FIX (PLUS -600 (TIMES 3 YYY))))
(SHOW 0)
(COND ((GREATERP (PLUS X W) (SETQ XX (ADD1 XX))) (GO L)))
(COND ((GREATERP (PLUS Y H) (SETQ YY (ADD1 YY))) (GO LL)))))
EXPR)
(DEFPROP TABLE
(LAMBDA NIL (PROG NIL (TILT -240) (PAN -40) (FOCUS 2300)))
EXPR)
(DEFPROP WALL
(LAMBDA NIL (PROG NIL (FOCUS 2500) (PAN 130) (TILT 500)))
EXPR)
(DEFPROP CLIPX
(LAMBDA NIL
(PROG (N)
(SETQ N 4)
(OUTPUT LPT:)
(OUTC T T)
L (CLIP 0 N (PLUS N 3))
(INTV)
(TVADD 0)
(PRINTV 200 300)
(ZIP)
(COND ((NOT (MINUSP (SETQ N (SUB1 N)))) (GO L)))
(OUTC NIL T)))
EXPR)
(DEFPROP QW
(LAMBDA NIL (PROG NIL (ZIP) (CTVF1) (PRINTV 160 300)))
EXPR)
(DEFPROP QW
(NIL -30 -155 10 -274 -644 1112 -55 -515 -31 672 116 -126 -614 254 413)
VALUE)
(DEFPROP TV
(LAMBDA (M) (PROG (N) (SETQ N M) L (INTV) (COND ((NOT (ZEROP (SETQ N (SUB1 N)))) (GO L)))))
EXPR)
(DEFPROP PRINTV
(LAMBDA(X Y)
(PROG (XX YY NN I J)
(SETQ NN 0)
L3 (SETQ YY Y)
(TERPRI)
(PRINC (QUOTE " "))
L2 (SETQ XX X)
(TERPRI)
L1 (SETQ J (FETCH NN XX YY))
(SETQ I (FLATSIZE J))
(COND ((EQ I 1) (PRINC (QUOTE " "))) ((EQ I 2) (PRINC (QUOTE " "))) (T (PRINC (QUOTE " "))))
(PRINC J)
(COND ((GREATERP (PLUS X 20) (SETQ XX (ADD1 XX))) (GO L1)))
(COND ((GREATERP (PLUS Y 4) (SETQ YY (ADD1 YY))) (GO L2)))
(COND ((GREATERP 4 (SETQ NN (ADD1 NN))) (GO L3)))))
EXPR)
(DEFPROP WINALL
(LAMBDA (X Y W H) (PROG NIL (WINDOW 1 X Y W H) (WINDOW 2 X Y W H) (WINDOW 3 X Y W H) (WINDOW 0 X Y W H)))
EXPR)